home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 05 - 1989 / 05.06 Jun 89 / Lisp sources / structures / errorHanoiDiskRules < prev    next >
Encoding:
Text File  |  1988-05-15  |  2.1 KB  |  63 lines  |  [TEXT/CCL ]
  1. ; Ted Kaehler and Dave Patterson a taste of SmallTalk
  2. ; W. W. Norton ed., chapter 6, pp. 83 ff.
  3. ; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
  4. ; © Copyright 1988 Jean-Pascal J. LANGE.
  5.  
  6. (proclaim '(optimize (speed 3)
  7.             (space 0)
  8.             (safety 0)
  9.             (compilation-speed 0) ))
  10.  
  11. (defStruct (HanoiDiskRules (:include HanoiDisk))
  12.   ; previousPole number of the pole this disk was on previously.
  13.   (previousPole nil) )
  14.  
  15. ; access
  16.  
  17. (deFun width (thisDisk)
  18.   ; return the size of this disk
  19.   (HanoiDiskRules-width thisDisk) ) ; width
  20.  
  21. (deFun widthPoleRules (thisDisk size whichPole)
  22.   ; invoke widthPole for HanoiDisk structure
  23.   (widthPole thisDisk size whichPole)
  24.   (setf (HanoiDiskRules-previousPole thisDisk) 1) ) ; widthPoleRules
  25.  
  26. ; moving
  27.  
  28. (deFun bestMove (thisDisk)
  29.   ; If self can move two places, which is the best? Return the top
  30.   ; disk of the pole that this disk has not been on recently.
  31.   (let ((secondBest))
  32.     (cond
  33.      ((polesOtherThan
  34.        *TheTowers*
  35.        thisDisk
  36.        #'(lambda (targetDisk)
  37.            (cond ((< (width thisDisk)
  38.                      (width targetDisk) )
  39.                   (setq thisDisk targetDisk)
  40.                   (if (not
  41.                        (= (pole targetDisk)
  42.                           (HanoiDiskRules-previousPole thisDisk) ) )
  43.                     targetDisk ) )) ) ) )
  44.      ; as a last resort, return a pole it was on recently
  45.      (t secondBest) ) ) ) ; bestMove
  46.  
  47. (deFun hasLegalMove (thisDisk)
  48.   ; do either of the other two poles have a top disk large enough
  49.   ; for this disk to rest on?
  50.   (polesOtherThan *TheTowers*
  51.                   thisDisk
  52.                   ; when a pole has no disk,
  53.                   ; targetDisk is a mock disk with infinite width
  54.                   #'(lambda (targetDisk)
  55.                       (< (width thisDisk)
  56.                          (width targetDisk) ) ) ) ) ; hasLegalMove
  57.  
  58. (deFun moveUponRules (thisDisk destination)
  59.   ; this disk just moved. Record the new pole and tell the user.
  60.   (setf (HanoiDiskRules-previousPole thisDisk) (pole thisDisk))
  61.   ; run the version of moveUpon defined for structure HanoiDisk
  62.   (moveUpon destination) ) ; moveUponRules
  63.